home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / inc / except.inc next >
Encoding:
Text File  |  1998-10-28  |  4.1 KB  |  190 lines
  1. {
  2.     $Id: except.inc,v 1.5 1998/08/02 16:43:35 florian Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1998 by Michael Van Canneyt
  5.     member of the Free Pascal development team
  6.  
  7.     See the file COPYING.FPC, included in this distribution,
  8.     for details about the copyright.
  9.  
  10.     This program is distributed in the hope that it will be useful,
  11.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  
  14.  **********************************************************************}
  15.  
  16. {****************************************************************************
  17.                                 Exception support
  18. ****************************************************************************}
  19.  
  20.  
  21. Const 
  22.   { Type of exception. Currently only one. } 
  23.   FPC_EXCEPTION   = 1;
  24.   { types of frames for the exception address stack }
  25.   cExceptionFrame = 1;
  26.   cFinalizeFrame  = 2;
  27.  
  28. Type
  29.   PExceptAddr = ^TExceptAddr;
  30.   TExceptAddr = record
  31.     buf : pjmp_buf;
  32.     frametype : Longint;
  33.     next : PExceptAddr;
  34.     end;
  35.  
  36.   PExceptObject = ^TExceptObject;
  37.   TExceptObject = record
  38.     FObject : TObject;
  39.     addr : pointer;
  40.     Next : PExceptObject;
  41.     end;
  42.  
  43.   TExceptObjectClass = Class of TObject;
  44.  
  45. Const 
  46.   CatchAllExceptions = -1;
  47.  
  48. Var ExceptAddrStack : PExceptAddr;
  49.     ExceptObjectStack : PExceptObject;
  50.  
  51.  
  52. Function PushExceptAddr (Ft: Longint): PJmp_buf ;[Public, Alias : 'FPC_PUSHEXCEPTADDR'];
  53.     
  54. var Buf : PJmp_buf; 
  55.     NewAddr : PExceptAddr;
  56.     
  57. begin
  58. {$ifdef excdebug}
  59.   writeln ('In PushExceptAddr');
  60. {$endif}
  61.   If ExceptAddrstack=Nil then
  62.     begin
  63.     New(ExceptAddrStack);
  64.     ExceptAddrStack^.Next:=Nil;
  65.     end
  66.   else
  67.     begin
  68.     New(NewAddr);
  69.     NewAddr^.Next:=ExceptAddrStack;
  70.     ExceptAddrStack:=NewAddr;
  71.     end;
  72.   new(buf);
  73.   ExceptAddrStack^.Buf:=Buf;
  74.   ExceptAddrStack^.FrameType:=ft;
  75.   PushExceptAddr:=Buf;
  76. end;
  77.  
  78.  
  79. Procedure PushExceptObj (Obj : TObject; AnAddr : Pointer);
  80.  
  81. var 
  82.     Newobj : PExceptObject;
  83.     
  84. begin
  85. {$ifdef excdebug}
  86.   writeln ('In PushExceptObject');
  87. {$endif}
  88.   If ExceptObjectStack=Nil then
  89.     begin
  90.     New(ExceptObjectStack);
  91.     ExceptObjectStack^.Next:=Nil;
  92.     end
  93.   else
  94.     begin
  95.     New(NewObj);
  96.     NewObj^.Next:=ExceptObjectStack;
  97.     ExceptObjectStack:=NewObj;
  98.     end;
  99.   ExceptObjectStack^.FObject:=Obj;
  100.   ExceptObjectStack^.Addr:=AnAddr;
  101. end;
  102.  
  103. Function Raiseexcept (Obj : TObject; AnAddr : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
  104.  
  105. begin
  106. {$ifdef excdebug}
  107.   writeln ('In RAiseException');
  108. {$endif}
  109.  
  110.   PushExceptObj(Obj,AnAddr);
  111.   longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
  112. end;
  113.  
  114. Procedure PopAddrStack ;[Public, Alias : 'FPC_POPADDRSTACK'];
  115.  
  116. begin
  117. {$ifdef excdebug}
  118.   writeln ('In Popaddrstack');
  119. {$endif}
  120.   If ExceptAddrStack=nil then
  121.     begin
  122.     writeln ('At end of ExceptionAddresStack');
  123.     halt (1);
  124.     end
  125.   else
  126.     ExceptAddrStack:=ExceptAddrStack^.Next;
  127. end;
  128.  
  129. Procedure PopObjectStack ;
  130.  
  131. begin
  132. {$ifdef excdebug}
  133.   writeln ('In PopObjectstack');
  134. {$endif}
  135.   If ExceptObjectStack=nil then
  136.     begin
  137.     writeln ('At end of ExceptionObjectStack');
  138.     halt (1);
  139.     end
  140.   else
  141.     ExceptObjectStack:=ExceptObjectStack^.Next;
  142. end;
  143.  
  144. Procedure ReRaise;[Public, Alias : 'FPC_RERAISE'];
  145.  
  146. begin
  147. {$ifdef excdebug}
  148.   writeln ('In reraise');
  149. {$endif}
  150.   PopAddrStack;
  151.   If ExceptAddrStack=Nil then
  152.     begin
  153.     If ExceptProc<>Nil then
  154.       If ExceptObjectStack<>Nil then
  155.         TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,
  156.                                 ExceptObjectStack^.Addr);
  157.     RunError(217);
  158.     end;
  159.   longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
  160. end;
  161.  
  162. Function Catches (Objtype : TExceptObjectClass) : TObject; [Public, Alias : 'FPC_CATCHES'];
  163.  
  164. begin
  165.   If ExceptObjectStack=Nil then
  166.     begin
  167.     Writeln ('Internal error.');
  168.     halt (255);
  169.     end; 
  170.   if Not ((Objtype = TExceptObjectClass(CatchAllExceptions)) or 
  171.       (ExceptObjectStack^.FObject is ObjType)) then
  172.     Catches:=Nil
  173.   else
  174.     begin
  175.     // catch !
  176.     Catches:=ExceptObjectStack^.FObject;
  177.     PopObjectStack;
  178.     PopAddrStack;
  179.     end;
  180. end;
  181.  
  182. Procedure InitExceptions;
  183. {
  184.   Initialize exceptionsupport
  185. }
  186. begin
  187.   ExceptObjectstack:=Nil;
  188.   ExceptAddrStack:=Nil;
  189. end;
  190.